home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Source.zip / Main.p < prev    next >
Text File  |  1990-02-06  |  9KB  |  414 lines
  1. Program PCQ_Pascal;
  2.  
  3. {
  4.     PCQ Pascal Compiler
  5.     Copyright (c) 1989 Patrick Quaid.
  6.  
  7.     This is the main file of the compiler.  When this file is
  8. compiled, it allocates BSS for all the global variables.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13. {$I "Include/StringLib.i"}
  14. {$I "Include/Parameters.i"}
  15.  
  16.     { The following routines are all exported by the other
  17.       compiler files. }
  18.  
  19.     Procedure Error(s : string);
  20.         external;
  21.     Function CheckID(s : string): IDPtr;
  22.         external;
  23.  
  24.     Function EnterStandard(    st_Name : String;
  25.                 st_Object : IDObject;
  26.                 st_Type : TypePtr;
  27.                 st_Storage : IDStorage;
  28.                 st_Offset : Integer) : IDPtr;
  29.         external;
  30.  
  31.     Procedure NextSymbol;
  32.         external;
  33.     Function Match(s : Symbols): Boolean;
  34.         external;
  35.     Procedure DeclType;
  36.         external;
  37.     Procedure DeclConst;
  38.         external;
  39.     Procedure DeclLabel;
  40.         External;
  41.     Function DeclArgs(ob : IDObject) : IDPtr;
  42.         external;
  43.     Procedure ns;
  44.         external;
  45.     Procedure EnterID(CB : BlockPtr; ID : IDPtr);
  46.         external;
  47.     Procedure ReformArgs(ID : IDPtr);
  48.         external;
  49.     Function ReadType(): TypePtr;
  50.         external;
  51.     Function EndOfFile(): boolean;
  52.         external;
  53.     Function OpenInputFile(n : String) : Boolean;
  54.         external;
  55.     Procedure CloseInputFile;
  56.         external;
  57.     Procedure VarDeclarations;
  58.         external;
  59.     Procedure InitReserved;
  60.         external;
  61.     Procedure InitGlobals;
  62.         external;
  63.     Function GetLabel() : Integer;
  64.         External;
  65.     Procedure DumpIds;
  66.         external;
  67.     Procedure DumpRefs;
  68.         external;
  69.     Procedure DumpLits;
  70.         external;
  71.     Procedure Trailer;
  72.         external;
  73.     Procedure Compound;
  74.         external;
  75.     Procedure Header;
  76.         external;
  77.     Procedure InitStandard;
  78.         external;
  79.     Procedure ReadChar;
  80.         external;
  81.     Procedure NeedRightParent;            { Utilities.p }
  82.         external;
  83.     Function SimpleType(T : TypePtr): Boolean;    { Utilities.p }
  84.         external;
  85.     Procedure NewBlock;                { Utilities.p }
  86.         external;
  87.     Procedure KillBlock;                { Utilities.p }
  88.         external;
  89.     Procedure KillIDList(ID : IDPtr);        { Utilities.p }
  90.         external;
  91.     Procedure Decompose;                { Utilities.p }
  92.         external;
  93.     Function CompareProcs(Proc1, Proc2 : IDPtr) : Boolean;    { Utilities.p }
  94.         external;
  95.     Procedure BackUpSpell(Position : Integer);
  96.         external;
  97.  
  98. Procedure Banner;
  99. begin
  100.     writeln('PCQ Compiler 1.1b  (February 5, 1990)');
  101.     writeln('Copyright ', chr(169),
  102.         ' 1989 Patrick Quaid.  All rights reserved.');
  103. end;
  104.  
  105. Procedure GetFileNames;
  106. var
  107.     Parm : String;
  108.     ParmNum : Short;
  109.  
  110.     Procedure Die(LastWords : string);
  111.     begin
  112.     Banner;
  113.     Writeln(LastWords);
  114.     Exit(20);
  115.     end;
  116.  
  117.     Procedure DoOption;
  118.     begin
  119.     if toupper(Parm[1]) = 'Q' then
  120.         Inform := False
  121.     else
  122.         Die("Unknown Directive");
  123.     end;
  124.  
  125. begin
  126.     Parm := AllocString(256);
  127.     MainName := Nil;
  128.     OutName := Nil;
  129.     ParmNum := 1;
  130.     repeat
  131.     GetParam(ParmNum, Parm);
  132.     if Parm^ = Chr(0) then begin
  133.         if MainName = Nil then
  134.         Die("No Input File Name");
  135.         if OutName = Nil then
  136.         Die("Missing Output File Name");
  137.     end else begin
  138.         if Parm^ = '-' then
  139.         DoOption
  140.         else if MainName = Nil then
  141.         MainName := strdup(Parm)
  142.         else if OutName = Nil then
  143.         OutName := strdup(Parm)
  144.         else
  145.         Die("Unknown Command");
  146.     end;
  147.     Inc(ParmNum);
  148.     until Parm^ = Chr(0);
  149.     FreeString(Parm);
  150. end;
  151.  
  152. Procedure OpenFiles;
  153. begin
  154.     InFile := nil;
  155.     if not OpenInputFile(MainName) then begin
  156.     Writeln('Could not open ', MainName);
  157.         Exit(20);
  158.     end;
  159.     if not open(OutName, OutFile, 2048) then begin
  160.     Writeln('Could not open ', OutName);
  161.     Exit(20);
  162.     end;
  163. end;
  164.  
  165. Procedure DoBlock(isfunction : boolean);
  166.  
  167.  
  168. {
  169.     This is the main routine for handling program, procedure
  170. and function blocks.  It handles the various declaration blocks and
  171. the procedure and function parameters.  This is one of the many
  172. routines which should, and will, be broken into more manageable
  173. parts.
  174. }
  175.  
  176. var
  177.     ID        : IDPtr;
  178.     DupID    : IDPtr;
  179.     savefn    : IDPtr;
  180.     ForwardID   : IDRec;
  181.     Forwarded    : Boolean;
  182.     FirstVar    : IDPtr;
  183.     SaveStack    : Integer;
  184.     SaveSpell    : Integer;
  185. begin
  186.     fnstart := lineno;
  187.     Forwarded := False;
  188.     FirstVar := Nil;
  189.     if CurrentBlock^.Level > 0 then begin
  190.     if currsym <> ident1 then begin
  191.         error("Missing function or procedure name!");
  192.         return;
  193.     end;
  194.     CurrFn := CheckID(symtext);
  195.     if CurrFn <> Nil then begin
  196.         if CurrFn^.Storage <> st_forward then
  197.         error("Duplicate ID")
  198.         else begin
  199.         ForwardID := CurrFn^;
  200.         Forwarded := True;
  201.         CurrFn^.Param := Nil;
  202.         end;
  203.     end else begin
  204.         case isfunction of
  205.         True : CurrFn := EnterStandard(symtext, func, Nil, st_none, 0);
  206.         False: CurrFn := EnterStandard(symtext, proc, Nil, st_none, 0);
  207.         end;
  208.         CurrFn^.Unique := GetLabel();
  209.     end;
  210.     nextsymbol;
  211.     SaveSpell := SpellPtr;
  212.  
  213.     if Match(leftparent1) then begin
  214.         CurrFn^.Param := DeclArgs(valarg); { Dummy param here }
  215.         ReformArgs(CurrFn); { Set offsets of args, plus totalsize }
  216.         NeedRightParent;
  217.     end else
  218.         CurrFn^.Param := Nil;
  219.  
  220.     if isfunction then begin
  221.         if not match(colon1) then
  222.         error("expecting :");
  223.         CurrFn^.VType := readtype();
  224.         if not simpletype(CurrFn^.VType) then begin
  225.         error("expecting a simple type");
  226.         CurrFn^.VType := BadType;
  227.         end;
  228.     end;
  229.     ns;
  230.     end;
  231.  
  232.     if match(forward1) then begin
  233.     if Forwarded then
  234.         Error("Already declared");
  235.     CurrFn^.Storage := st_forward;
  236.     ns;
  237.     end else if Match(extern1) then begin
  238.     CurrFn^.Storage := st_external;
  239.     ns;
  240.     end else begin
  241.     if Forwarded then begin
  242.         if not CompareProcs(Adr(ForwardID), CurrFn) then
  243.         Error("Definitions do not match");
  244.         KillIDList(ForwardID.Param);
  245.     end;
  246.     NewBlock;
  247.     if CurrentBlock^.Level > 1 then begin
  248.         CurrFn^.Storage := st_internal;
  249.         ID := CurrFn^.Param;
  250.         while ID <> nil do begin
  251.         New(DupID);
  252.         DupID^ := ID^;
  253.         ID^.Name := Nil;
  254.         EnterID(CurrentBlock, DupID);
  255.         ID := ID^.Next;
  256.         end;
  257.     end;
  258.  
  259.     StackSpace := 0;
  260.  
  261.     while currsym <> begin1 do begin
  262.         if endoffile() then begin
  263.         if mainmode or (CurrentBlock^.Level > 1) then
  264.             error("There was no code section!");
  265.         return;
  266.         end else if match(var1) then
  267.         VarDeclarations
  268.         else if match(type1) then
  269.         DeclType
  270.         else if match(const1) then
  271.         DeclConst
  272.         else if match(proc1) then begin
  273.         savefn := currfn;
  274.         SaveStack := StackSpace;
  275.         doblock(false);
  276.         StackSpace := SaveStack;
  277.         currfn := savefn;
  278.         end else if match(func1) then begin
  279.         savefn := currfn;
  280.         SaveStack := StackSpace;
  281.         doblock(true);
  282.         StackSpace := SaveStack;
  283.         currfn := savefn;
  284.         end else if match(label1) then
  285.         DeclLabel
  286.         else begin
  287.         error("expecting block identifier");
  288.         nextsymbol;
  289.         end;
  290.     end;
  291.  
  292.     if CurrentBlock^.Level > 1 then begin
  293.         if odd(StackSpace) then
  294.         StackSpace := Succ(StackSpace);
  295.         CurrFn^.Offset := StackSpace;
  296.     end;
  297.  
  298.     if (not mainmode) and (CurrentBlock^.Level = 1) then begin
  299.         error("Expected a procedure or function header");
  300.         return;
  301.     end;
  302.     case CurrentBlock^.Level of
  303.       1 : if MainMode then begin
  304.           writeln(OutFile, '_MAIN');
  305.           end;
  306.       2 : begin
  307.           if StandardStorage <> st_private then
  308.               writeln(OutFile, "\n\tXDEF\t_", CurrFn^.Name);
  309.           writeln(OutFile, '_', CurrFn^.Name, "\tlink\ta5,#",
  310.                 -CurrFn^.Offset);
  311.           end;
  312.     else
  313.         Writeln(OutFile, '_', CurrFn^.Name, '%', CurrFn^.Unique,
  314.                 "\tlink\ta5,#", -CurrFn^.Offset);
  315.     end;
  316.     NextSymbol;
  317.  
  318.     Compound;
  319.  
  320.     if CurrentBlock^.Level > 1 then begin
  321.         ns;
  322.         writeln(OutFile, "\tunlk\ta5");
  323.        { Decompose; }
  324.         KillBlock;
  325.         BackUpSpell(SaveSpell);
  326.     end;
  327.     writeln(OutFile, "\trts");
  328.     end;
  329. end;
  330.  
  331.  
  332. Procedure Parse;
  333.  
  334. {
  335.     This is the outermost parsing routine.  It uses doblock()
  336. mainly, and will eventually be able to handle program parameters.
  337. }
  338.  
  339. begin
  340.     if Match(program1) then begin
  341.     mainmode:= true;
  342.     StandardStorage := st_internal;
  343.     if currsym = ident1 then
  344.         NextSymbol { Eat program name }
  345.     else
  346.         error("Missing program name.");
  347.     if Match(LeftParent1) then begin
  348.         while CurrSym = Ident1 do begin
  349.         NextSymbol;
  350.         if CurrSym <> RightParent1 then
  351.             if not Match(Comma1) then
  352.             Error("Expecting a comma");
  353.         end;
  354.         NeedRightParent;
  355.     end;
  356.     ns;
  357.     end else if match(extern1) then begin
  358.     mainmode := false;
  359.     StandardStorage := st_external;
  360.     ns;
  361.     end else begin
  362.     error("First symbol must be PROGRAM or EXTERNAL.");
  363.     StandardStorage := st_internal;
  364.     MainMode:= false;
  365.     end;
  366.     Header;
  367.     DoBlock(false);
  368.     if MainMode then
  369.     if not Match(period1) then
  370.         Error("Program must end with a period.");
  371.     if (not EndOfFile) and (MainMode) then
  372.     Error("There should be nothing after the main procedure.");
  373. end;
  374.  
  375. begin
  376.  
  377. {
  378.     This is the big one, the main routine, which by itself does
  379. very little.  Read parse() and doblock() to get a much better idea
  380. of how things work.
  381. }
  382.  
  383.     initglobals;    { initialize everything }
  384.     initreserved;
  385.     initstandard;
  386.  
  387.     GetFileNames;
  388.     if Inform then
  389.     Banner;
  390.     OpenFiles;
  391.  
  392.     nextsymbol;
  393.  
  394.     parse;     { do everything }
  395.  
  396.     if Inform then begin
  397.     if errorcount = 0 then
  398.         writeln('There were no errors.')
  399.     else if errorcount = 1 then
  400.         writeln('There was one error')
  401.     else
  402.         writeln('There were ', errorcount, ' errors.');
  403.     end;
  404.  
  405.     DumpRefs;
  406.     DumpLits;
  407.     DumpIds;        { write IDs and literals to assem file }
  408.     trailer;        { write 'END' }
  409.     while InFile <> nil do
  410.     CloseInputFile;    { be sure to close the main file }
  411.     if errorcount <> 0 then
  412.     exit(10);    { make sure there's an error if necessary }
  413. end.
  414.